home *** CD-ROM | disk | FTP | other *** search
/ Windows Expert / Windows Expert.iso / utility / wxlslib.zip / xlslib / objects.lsp < prev    next >
Lisp/Scheme  |  1992-02-20  |  6KB  |  178 lines
  1. ;;;;
  2. ;;;; objects.lsp XLISP-STAT additional objects and object functions
  3. ;;;; XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney
  4. ;;;; Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz
  5. ;;;; You may give out copies of this software; for conditions see the file
  6. ;;;; COPYING included with this distribution.
  7. ;;;;
  8.  
  9. (provide "objects")
  10.  
  11. (defsetf slot-value slot-value)
  12.  
  13. (defmeth *object* :new (&rest args)
  14. "Method args: (&rest args)
  15. Creates new object using self as prototype."
  16.   (let* ((object (make-object self)))
  17.     (if (slot-value 'instance-slots)
  18.         (dolist (s (slot-value 'instance-slots))
  19.                 (send object :add-slot s (slot-value s))))
  20.     (apply #'send object :isnew args)
  21.     object))
  22.  
  23. (defmeth *object* :retype (proto &rest args)
  24. "Method args: (proto &rest args)
  25. Changes object to inherit directly from prototype PROTO. PROTO
  26. must be a prototype and SELF must not be one."
  27.   (if (send self :has-slot 'instance-slots :own t) 
  28.       (error "can't retype a prototype"))
  29.   (if (not (send proto :has-slot 'instance-slots :own t))
  30.       (error "not a prototype - ~a" proto))
  31.   (send self :reparent proto)
  32.   (dolist (s (send proto :slot-value 'instance-slots))
  33.     (send self :add-slot s (slot-value s)))
  34.   (apply #'send self :isnew args)
  35.   self)
  36.  
  37. (defmeth *object* :print (&optional (stream *standard-output*))
  38. "Method args: (&optional (stream *standard-output*))
  39. Default object printing method."
  40.   (cond
  41.     ((send self :has-slot 'proto-name) 
  42.      (format stream
  43.              "#<Object: ~D, prototype = ~A>"
  44.              (address-of self)
  45.              (slot-value 'proto-name)))
  46.     (t (format stream "#<Object: ~D>" (address-of self)))))
  47.  
  48. (defmeth *object* :slot-value (sym &optional (val nil set))
  49. "Method args: (sym &optional val)
  50. Sets and retrieves value of slot named SYM. Sugnals an error if slot
  51. does not exist."
  52.   (if set (setf (slot-value sym) val))
  53.   (slot-value sym))
  54.  
  55. (defmeth *object* :slot-names () 
  56. "Method args: ()
  57. Returns list of slots available to the object."
  58.   (apply #'append 
  59.          (mapcar #'(lambda (x) (send x :own-slots))
  60.                  (send self :precedence-list))))
  61.  
  62. (defmeth *object* :method-selectors ()
  63. "Method args: ()
  64. Returns list of method selectors available to object."
  65.   (apply #'append
  66.          (mapcar #'(lambda (x) (send x :own-methods))
  67.                  (send self :precedence-list))))
  68.  
  69. ;;;;
  70. ;;;; More Hardware Object Methods
  71. ;;;;
  72. #+windows
  73. (progn
  74. (defmeth hardware-object-proto :remove () (send self :dispose))
  75. (defmeth hardware-object-proto :allocated-p () (slot-value 'hardware-address))
  76.  
  77. (defmeth hardware-object-proto :add-subordinate (d)
  78.   (setf (slot-value 'subordinates) (adjoin d (slot-value 'subordinates))))
  79.  
  80. (defmeth hardware-object-proto :delete-subordinate (d)
  81.   (setf (slot-value 'subordinates) (remove d (slot-value 'subordinates))))
  82.   
  83. (defmeth hardware-object-proto :clobber ()
  84.   (if (slot-value 'subordinates)
  85.       (dolist (i (slot-value 'subordinates)) (send i :remove))))
  86.  
  87. #+macintosh (progn
  88.              ;;; DISPLAY-WINDOW-PROTO
  89.              (defproto display-window-proto '() '() edit-window-proto)
  90.  
  91.              (defmeth display-window-proto :isnew (&rest args)
  92.                (apply #'call-next-method args)
  93.                (setf (slot-value 'input-enabled) nil)))
  94.  
  95. (defun active-windows ()
  96. "Args: ()
  97. Returns list of active windows."
  98.     (remove-if-not #'(lambda (x) (kind-of-p x window-proto))
  99.                    (mapcar #'third *hardware-objects*)))
  100.  
  101. ;;;;
  102. ;;;; More Dialogs and Menu Items
  103. ;;;;
  104.  
  105. (send dialog-proto :slot-value 'type 'modeless)
  106. (send dialog-proto :slot-value 'go-away t)
  107.  
  108. (defmeth dialog-proto :items () (slot-value 'items))
  109.  
  110. (defmeth dialog-item-proto :dialog () (slot-value 'dialog))
  111.  
  112. (defproto edit-text-item-proto () () text-item-proto)
  113. (send edit-text-item-proto :slot-value 'editable t)
  114.  
  115. ;;; MODAL-DIALOG-PROTO
  116. (defproto modal-dialog-proto '(modal-throw-target) () dialog-proto)
  117. (send modal-dialog-proto :slot-value 'type 'modal)
  118. (send modal-dialog-proto :slot-value 'go-away nil)
  119.  
  120. (defmeth modal-dialog-proto :modal-dialog (&optional (remove t))
  121. "Metod args: (&optional (remove t))
  122. Runs the modal dialog loop until the :modal-dialog-return message
  123. is sent. Returns the argument to :modal-dialog-return. If REMOVE
  124. is not NIL, dialog is sent the :remove message before returning."
  125.   (let ((target self))
  126.     (unless (slot-value 'modal-throw-target)
  127.             (setf (slot-value 'modal-throw-target) target)
  128.             (send self :show-window)
  129.             (unwind-protect (catch target 
  130.                                    (loop (send (call-next-method) :do-action)))
  131.                             (setf (slot-value 'modal-throw-target) nil)
  132.                             (if remove (send self :remove))))))
  133.  
  134. (defmeth modal-dialog-proto :modal-dialog-return (value)
  135. "Method Args: (value)
  136. Ends modal dialog loop and has :modal-dialog return VALUE."
  137.   (let ((target (slot-value 'modal-throw-target)))
  138.     (if target (throw target value))))
  139.  
  140. ;;; MODAL-BUTTON-PROTO
  141. (defproto modal-button-proto '() () button-item-proto)
  142.   
  143. (defmeth modal-button-proto :do-action ()
  144.   (let ((action (slot-value 'action))
  145.         (dialog (slot-value 'dialog)))
  146.     (if dialog 
  147.         (send dialog :modal-dialog-return (if action (funcall action))))))
  148.  
  149. ;; DASH-ITEM-PROTO. Disabled line item for separation 
  150. (defproto dash-item-proto () () menu-item-proto "Disabled separator line")
  151.  
  152. (defmeth dash-item-proto :isnew () (call-next-method "-" :enabled nil))
  153.  
  154. (defmeth menu-item-proto :menu () 
  155. "Method args: ()
  156. Returns menu if item is installed, NIL otherwise."
  157.   (slot-value 'menu))
  158.  
  159. (defmeth menu-proto :print (&optional (stream t))
  160.   (format stream "#<Object: ~d, prototype = ~a, title = ~s>"
  161.           (address-of self)
  162.           (slot-value 'proto-name)
  163.           (slot-value 'title)))
  164.  
  165. (defmeth menu-item-proto :print (&optional stream)
  166.   (format stream "#<Object: ~d, prototype = ~a, title = ~s>"
  167.           (address-of self)
  168.           (slot-value 'proto-name)
  169.           (slot-value 'title)))
  170.  
  171. (defmeth graph-window-proto :erase-window ()
  172. "Method args: ()
  173. Erases the entire window canvas."
  174.   (let ((w (send self :canvas-width))
  175.         (h (send self :canvas-height)))
  176.     (send self :erase-rect 0 0 w h)))
  177. )
  178.